perm filename PASS3.SAI[AL,HE]29 blob
sn#543575 filedate 1980-11-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00024 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION)
C00005 00003 ! Declarations, overall description
C00009 00004 ! COMERR, GENLABEL, INITOUT, CLOSEOUT
C00012 00005 ! EMIT, MAKE_REMARK
C00015 00006 ! EMITSYM, EMITOFFSET, EMITSMLBLK
C00018 00007 ! EMITSUBS, EMITARGS, EMITCALL, PRINT_LIST
C00021 00008 ! EMITEXPR: ONEARG, TWOARGS, THREEARGS
C00025 00009 ! EMITEXPR: variable, constant
C00035 00010 ! EMITEXPR: expression
C00046 00011 ! EMITBOOL
C00048 00012 ! ENV_SIZE
C00051 00013 ! TSCAN: STMNT, PROG
C00056 00014 ! TSCAN: BLOCK
C00069 00015 ! TSCAN: BLOCK continued
C00078 00016 ! TSCAN: COBLOCK
C00081 00017 ! TSCAN: FORR, WHIL, UNTL, IFF, CASE, PAUSE, PROMPT, ABORT
C00089 00018 ! TSCAN: ASSIGNMENT, S_FAC, PRNT, CALL, RETURN, TOVAL, DAC
C00093 00019 ! TSCAN: CMON, CMABLE
C00095 00020 ! TSCAN: MOVE$
C00114 00021 ! TSCAN: OPERATE, CENTER, RETRY, STOP, SETBASE, WRIST
C00123 00022 ! TSCAN: COMMENT, AFFIX, UNFIX
C00127 00023 ! TSCAN: EVDO
C00128 00024 ! UNRECOGNIZED
C00129 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION)
THENC
ENTRY;
BEGIN "PASS3"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = "FALSE"; ENDC
IFCR ¬ CREFFING THENC
COMMENT: Source file requirements;
REQUIRE "ABBREV.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "RECAUX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "ARITH.HDR[AL,HE]" SOURCE_FILE ;
REQUIRE "ALREC.SAI[AL,HE]" SOURCE_FILE ;
ENDC
REDEFINE $$PRGID "[]" = ["PASS3"];
IFCR CREFFING THENC REQUIRE $$PRGID MESSAGE; ENDC
REQUIRE "INTDEF.SAI[AL,HE]" SOURCE_FILE;
ENDC
! Declarations, overall description;
! The word that heads a constant gives its type. (These are also used
by MVAR.) These are they:;
DEFINE SCLID = 1;
DEFINE VCTID = 2;
DEFINE TRNID = 3;
DEFINE EVTID = 4;
DEFINE CMNID = 5;
DEFINE STRID = 6;
DEFINE ARYID = '1000;
DEFINE PROID = '4000;
DEFINE REFID = '2000; ! for procedure arguments;
! This file contains all the routines necessary for implementing the
third pass of AL, that is, the code generator.
The principal routine is TSCAN, which generates code for the root of
the bound parse tree and calls itself recursively for the rest. The
structures in this tree are defined in ALREC[AL,HE], page three.
TSCAN is a large IF-THEN-ELSE-IF-THEN chain which determines which of
the various possible structures is present. If it is some kind of
statement, then appropriate pseudo-code is emitted. The preparation
of this code may require that code for the evaluation of an
expression. Such code is prepared in the recursive procedure
EMITEXPR, which performs type-consistency checking (but not constant
folding, which could be done here). Code for boolean tests is
prepared by EMITBOOL.
All code emission is done through the routine EMIT, which takes arguments
specifying the data to output, and whether to treat it as an instruction,
an octal constant, a label declaration, or repeatedly to produce the rel file. ;
! RELOC constants;
DEFINE PSINST = "0"; ! Pseudo-instruction;
DEFINE SYMDEC = "1"; ! Declaration of numbered symbol;
DEFINE SYMREF = "2"; ! Reference to numbered symbol;
DEFINE STRCONST = "3"; ! String constant;
DEFINE SKIP = "6"; ! Skip some words (DATA tells how many);
DEFINE CONST = "7"; ! Just a constant;
DEFINE OCONST = "8"; ! Just an octal constant;
DEFINE FLOAT = "9"; ! A floating point constant;
DEFINE DUMMY = "0";
DEFINE YARM_MECH = "'1";
DEFINE YHAND_MECH = "'2";
DEFINE BARM_MECH = "'4";
DEFINE BHAND_MECH = "'10";
DEFINE AHAND_MECH = "'12";
DEFINE ANARM_MECH = "'5";
DEFINE VISE_MECH = "'20";
DEFINE DRIVER_MECH = "'40";
DEFINE YARMSB = "'176000";
DEFINE YHANDSB = "'1000";
DEFINE BARMSB = "'770";
DEFINE BHANDSB = "'4";
DEFINE VISESB = "'2";
DEFINE DRIVERSB = "'1";
! COMERR, GENLABEL, INITOUT, CLOSEOUT;
PROCEDURE COMERR
(STRING MESSG;RECORD_POINTER(ANY_CLASS) CONTXT (NULL_RECORD));
! Non-fatal warnings;
BEGIN
EXTERNAL RECURSIVE PROCEDURE ALPRIN
(RECORD_POINTER(ANY_CLASS) S);
IF CONTXT≠NULL_RECORD THEN ALPRIN(CONTXT);
USERERR(0,1,"HAH! "&MESSG);
END;
INTEGER PROCEDURE GENLABEL;
BEGIN ! Makes a new label for the PALX output;
OWN INTEGER LAB;
RETURN(LAB ← LAB + 1);
END;
INTEGER REL; ! Channel number;
INTEGER RELS; ! Channel number;
BOOLEAN SYM_FILE; ! If true generate a symbol file, else don't;
INTERNAL PROCEDURE INITOUT(STRING FNAME,PPN; BOOLEAN SF(TRUE));
BEGIN "initout" ! Initialize the output stream(s), going to the file(s):
FNAME.ALP (&.ALS);
INTEGER COUNT, BRCHAR, EOF, FLAG;
REL ← GETCHAN;
OPEN(REL,"DSK",0,0,2,COUNT,BRCHAR,EOF);
ENTER(REL,FNAME&".ALP"&PPN,FLAG);
IF FLAG THEN COMERR("I can't enter "&FNAME&".ALP");
IF SF THEN
BEGIN
RELS ← GETCHAN;
OPEN(RELS,"DSK",0,0,2,COUNT,BRCHAR,EOF);
ENTER(RELS,FNAME&".ALS"&PPN,FLAG);
IF FLAG THEN COMERR("I can't enter "&FNAME&".ALS");
SYM_FILE ← TRUE
END
ELSE SYM_FILE ← FALSE
END "initout";
INTERNAL PROCEDURE CLOSEOUT;
BEGIN ! Close all channels;
CLOSE(REL);
IF SYM_FILE THEN CLOSE(RELS);
END;
! EMIT, MAKE_REMARK;
PROCEDURE EMIT(REFERENCE INTEGER DATA, RELOC; INTEGER LTH (1));
BEGIN "emit"
! Appends to PAL file. DATA and RELOC are the first words in a block of
size LTH. DATA holds the actual output, and RELOC holds relocation information
about how to treat the word in DATA;
INTEGER J, K, DAT;
EXTERNAL STRING ARRAY PSOP[1:300];
FOR J ← 0 STEP 1 UNTIL LTH-1 DO
BEGIN "emitloop"
DAT ← MEMORY[LOC(DATA) + J];
CASE MEMORY[LOC(RELOC) + J] OF
BEGIN "case"
[PSINST] OUT(REL,TAB & PSOP[DAT] & CRLF);
[SYMDEC] OUT(REL,"L" & CVOS(DAT) & ":");
[SYMREF] OUT(REL,(TAB & "L") & CVOS(DAT) & CRLF);
[SKIP] OUT(REL,(TAB & ".BLKW" & TAB) & CVOS(DAT) & CRLF);
[CONST] OUT(REL,TAB & CVS(DAT LAND '177777) & "." & CRLF);
[OCONST] OUT(REL,TAB & CVOS(DAT LAND '177777) & CRLF);
[FLOAT] OUT(REL,TAB & ".FLT2" & TAB & CVF(MEM[LOC(DAT),REAL]) & CRLF);
[STRCONST] BEGIN "strconst"
! DAT is the location of a string constant;
STRING STR;
MEMLOC(STR,INTEGER) ← DAT;
MEMLOC(STR,INTEGER) ← MEM[DAT,INTEGER];
MEM[LOC(STR)-1,INTEGER] ← MEM[DAT-1,INTEGER];
OUT(REL,TAB & "ASCIE ↑∀" & STR & "∀" & CRLF);
END "strconst"
END "case";
END "emitloop";
END "emit";
PROCEDURE MAKE_REMARK(STRING REMK);
BEGIN "make_remark" ! Outputs this remark to the ALP file;
OUT(REL,(TAB & TAB & ";") & REMK & CRLF);
END "make_remark";
! EMITSYM, EMITOFFSET, EMITSMLBLK;
PROCEDURE EMITSYM(RANY VARBL);
BEGIN "emitsym"
! Outputs into the sym file the offset of VARBL, making a remark;
INTEGER DUMY;
IF ¬SYM_FILE THEN RETURN;
IF RECTYPE(VARBL) = LOC(EXPRN) THEN VARBL ← CELL:CAR[EXPRN:ARGS[VARBL]];
OUT(RELS,(TAB & TAB & ";") & VARIABLE:NAME[VARBL] & CRLF);
OUT(RELS,TAB & CVOS(VARIABLE:OFFSET[VARBL] LAND '177777) & CRLF);
END "emitsym";
PROCEDURE EMITOFFSET(RANY VARBL);
BEGIN "emitoffset"
! Outputs the offset of VARBL, making a remark;
INTEGER DUMY;
IF RECTYPE(VARBL) = LOC(EXPRN) THEN VARBL ← CELL:CAR[EXPRN:ARGS[VARBL]];
MAKE_REMARK(VARIABLE:NAME[VARBL]);
EMIT(VARIABLE:OFFSET[VARBL],OCONST);
END "emitoffset";
PROCEDURE EMITSMLBLK(INTEGER LENGTH; REFERENCE REAL FIRST_ELT);
BEGIN "emitsmlblk"
! Emits a constant in the small block area. The length is
given, as is the first element, so that the whole thing can be
grabbed by location. Note that LENGTH must not be greater than 3;
OWN INTEGER ARRAY DATA [1:3]; ! maxlength long;
INTEGER ARRAY RELOC [1:3];
INTEGER J, ADDR, K;
IF LENGTH > 3
THEN BEGIN
COMERR("EMITSMLBLK cannot handle length = " & CVS(LENGTH));
LENGTH ← 3;
END;
K ← 1;
ADDR ← LOC(FIRST_ELT);
FOR J ← 0 STEP 1 UNTIL LENGTH-1 DO
BEGIN "stuff";
DATA[K] ← MEM[ADDR + J,INTEGER];
RELOC[K] ← FLOAT;
K ← K + 1;
END "stuff";
EMIT(DATA[1],RELOC[1],K-1);
END "emitsmlblk";
! EMITSUBS, EMITARGS, EMITCALL, PRINT_LIST;
FORWARD RECURSIVE INTEGER PROCEDURE EMITEXPR(REXPR XPRESS;BOOLEAN GET(TRUE));
RECURSIVE PROCEDURE EMITSUBS(RCELL C);
BEGIN ! place subscripts on stack;
IF C = RNULL THEN RETURN;
EMITSUBS(CELL:CDR[C]);
EMITEXPR(CELL:CAR[C])
END;
RECURSIVE PROCEDURE EMITARGS(RCELL A);
BEGIN ! puts expressions on stack;
IF A = RNULL THEN RETURN;
EMITARGS(CELL:CDR[A]);
IF RECTYPE(CELL:CAR[A]) = LOC(EXPRN) THEN
IF EXPRN:OP[CELL:CAR[A]] = AREF_OP THEN ! put subscripts on stack;
EMITSUBS(CELL:CDR[EXPRN:ARGS[CELL:CAR[A]]])
ELSE EMITEXPR(CELL:CAR[A]) ! put expression on stack;
END;
RECURSIVE INTEGER PROCEDURE EMITCALL(REXPR E);
BEGIN ! generates code for a procedure call;
RCELL C;
C ← EXPRN:ARGS[E];
EMITARGS(CELL:CDR[C]); ! put any expressions on stack;
EMIT(PROC_PSOP,PSINST); ! generate the procedure call;
EMITOFFSET(LLOP(C));
WHILE C ≠ RNULL DO ! now generate the argument list;
BEGIN
IF RECTYPE(CELL:CAR[C]) = LOC(EXPRN)
∧ EXPRN:OP[CELL:CAR[C]] ≠ AREF_OP THEN
EMIT('177777,OCONST) ! expr's value is on stack;
ELSE EMITEXPR(CELL:CAR[C],FALSE); ! give offset/address;
C ← CELL:CDR[C]
END;
RETURN(PROCDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[E]]])
END;
RECURSIVE PROCEDURE PRINT_LIST(RCELL C);
BEGIN
INTEGER LAB;
IF C ≠ RNULL THEN MAKE_REMARK("Print");
WHILE C ≠ RNULL DO
BEGIN "print list"
EMITEXPR(CELL:CAR[C]); ! Get the value on the stack;
EMIT(VALPRN_PSOP,PSINST);
C ← CELL:CDR[C];
END "print list"
END;
! EMITEXPR: ONEARG, TWOARGS, THREEARGS;
RECURSIVE INTEGER PROCEDURE EMITEXPR (REXPR XPRESS;BOOLEAN GET(TRUE));
! Emits code for XPRESS, the value of which is to be left at top
of stack, returns the type of the expression. FRAME_DTYPE is
never returned. It is coerced to TRANS_DTYPE;
BEGIN "emitexpr"
INTEGER RTYPE, DTYPE;
RECURSIVE PROCEDURE ONEARG(INTEGER ARG1TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up one argument, evaluate;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK("first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type of argument",XXX);
EMIT(OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
RECURSIVE PROCEDURE TWOARGS
(INTEGER ARG1TYPE,ARG2TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up two arguments, evaluate them;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK("first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type for first argument",XXX);
MAKE_REMARK("second argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XXX])) ≠ ARG2TYPE
THEN COMERR("Wrong type for second argument",XXX);
EMIT(OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
RECURSIVE PROCEDURE THREEARGS
(INTEGER ARG1TYPE,ARG2TYPE,ARG3TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up three arguments, evaluate;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK("first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type for first argument",XXX);
MAKE_REMARK("second argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XXX])) ≠ ARG2TYPE
THEN COMERR("Wrong type for second argument",XXX);
MAKE_REMARK("third argument");
IF EMITEXPR(CADDR(EXPRN:ARGS[XXX])) ≠ ARG3TYPE
THEN COMERR("Wrong type for third argument",XXX);
EMIT(OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
! EMITEXPR: variable, constant;
PRELOAD_WITH PUSH_PSOP, DUMMY;
OWN INTEGER ARRAY DATA[0:1];
PRELOAD_WITH PSINST, SYMREF;
OWN INTEGER ARRAY RELOC [0:1];
! For constants a list is kept & they are all emitted after the pcode;
RECORD_CLASS CONLST(RPTR(SVAL,V3ECT,ROTN,TRANS,STCONST) VAL; INTEGER LAB;
RPTR(CONLST) NEXT);
OWN RPTR(CONLST) SVAL_HDR,V3ECT_HDR,ROTN_HDR,TRANS_HDR,STR_HDR;
RPTR(CONLST) PTR;
INTEGER LAB;
RTYPE ← RECTYPE(XPRESS);
! A variable?;
IF RTYPE = LOC(VARIABLE) ∨ RTYPE = LOC(ARRAYDEF)
THEN BEGIN "variable"
IF GET THEN EMIT(GTVAL_PSOP,PSINST);
EMITOFFSET(XPRESS);
DTYPE ← VARIABLE:DATATYPE[XPRESS];
END "variable"
! A constant?;
ELSE IF RTYPE = LOC(SVAL)
THEN BEGIN "scalar"
PTR ← SVAL_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF SVAL:VAL[XPRESS] = SVAL:VAL[CONLST:VAL[PTR]] THEN DONE
ELSE PTR ← CONLST:NEXT[PTR];
IF PTR = RNULL THEN
BEGIN ! Add it to the conlst;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB ← GENLABEL;
CONLST:NEXT[PTR] ← SVAL_HDR;
SVAL_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(DATA[0],RELOC[0],2)
ELSE EMIT(LAB,SYMREF);
DTYPE ← SVAL_DTYPE;
END "scalar"
ELSE IF RTYPE = LOC(V3ECT)
THEN BEGIN "vector"
PTR ← V3ECT_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF V3CMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Add it to the conlst;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB ← GENLABEL;
CONLST:NEXT[PTR] ← V3ECT_HDR;
V3ECT_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(DATA[0],RELOC[0],2)
ELSE EMIT(LAB,SYMREF);
DTYPE ← V3ECT_DTYPE;
END "vector"
ELSE IF RTYPE = LOC(ROTN)
THEN BEGIN "rot" ! Will output the equivalent trans;
PTR ← ROTN_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF ROTCMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Add it to the conlst;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB ← GENLABEL;
CONLST:NEXT[PTR] ← ROTN_HDR;
ROTN_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(DATA[0],RELOC[0],2)
ELSE EMIT(LAB,SYMREF);
DTYPE ← ROTN_DTYPE;
END "rot"
ELSE IF RTYPE = LOC(TRANS)
THEN BEGIN "trans"
PTR ← TRANS_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF TRANSCMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Add it to the conlst;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB ← GENLABEL;
CONLST:NEXT[PTR] ← TRANS_HDR;
TRANS_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(DATA[0],RELOC[0],2)
ELSE EMIT(LAB,SYMREF);
DTYPE ← TRANS_DTYPE;
END "trans"
ELSE IF RTYPE = LOC(FRAME)
THEN BEGIN "frame" ! Recursive call to pick up the trans inside;
EMITEXPR(FRAME:VAL[XPRESS],GET);
DTYPE ← FRAME_DTYPE;
END "frame"
ELSE IF RTYPE = LOC(STCONST)
THEN BEGIN "strng"
PTR ← STR_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF EQU(STCONST:VAL[XPRESS],STCONST:VAL[CONLST:VAL[PTR]]) THEN DONE
ELSE PTR ← CONLST:NEXT[PTR];
IF PTR = RNULL THEN
BEGIN ! Add it to the conlst;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB ← GENLABEL;
CONLST:NEXT[PTR] ← STR_HDR;
STR_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(DATA[0],RELOC[0],2)
ELSE EMIT(LAB,SYMREF);
END "strng"
ELSE IF RTYPE = LOC(PROG)
THEN BEGIN "dump constants" ! Now emit all of the constants;
MAKE_REMARK("Scalar constants");
PTR ← SVAL_HDR;
WHILE PTR ≠ RNULL DO ! Emit scalars;
BEGIN
EMIT(SCLID,CONST); ! Header for typing;
EMIT(CONLST:LAB[PTR],SYMDEC);
EMITSMLBLK(1,SVAL:VAL[CONLST:VAL[PTR]]);
PTR ← CONLST:NEXT[PTR];
END;
MAKE_REMARK("Vector constants");
PTR ← V3ECT_HDR;
WHILE PTR ≠ RNULL DO ! Emit vectors;
BEGIN
EMIT(VCTID,CONST); ! Header for typing;
EMIT(CONLST:LAB[PTR],SYMDEC);
EMITSMLBLK(3,V3ECT:X[CONLST:VAL[PTR]]);
EMITSMLBLK(1,1.0); ! This puts the scale factor in;
PTR ← CONLST:NEXT[PTR];
END;
MAKE_REMARK("Rotation constants");
PTR ← ROTN_HDR;
WHILE PTR ≠ RNULL DO
BEGIN
EMIT(TRNID,CONST); ! Header for typing;
EMIT(CONLST:LAB[PTR],SYMDEC);
EMITSMLBLK(3,ROTN:RMX[CONLST:VAL[PTR]][1,1]);
EMITSMLBLK(3,ROTN:RMX[CONLST:VAL[PTR]][2,1]);
EMITSMLBLK(3,ROTN:RMX[CONLST:VAL[PTR]][3,1]);
EMITSMLBLK(3,V3ECT:X[NILVECT]); ! The fourth column;
PTR ← CONLST:NEXT[PTR];
END;
MAKE_REMARK("Trans constants");
PTR ← TRANS_HDR;
WHILE PTR ≠ RNULL DO ! Emit transes;
BEGIN
EMIT(TRNID,CONST); ! Header for typing;
EMIT(CONLST:LAB[PTR],SYMDEC);
EMITSMLBLK(3,ROTN:RMX[TRANS:R[CONLST:VAL[PTR]]][1,1]);
EMITSMLBLK(3,ROTN:RMX[TRANS:R[CONLST:VAL[PTR]]][2,1]);
EMITSMLBLK(3,ROTN:RMX[TRANS:R[CONLST:VAL[PTR]]][3,1]);
EMITSMLBLK(3,V3ECT:X[TRANS:P[CONLST:VAL[PTR]]]); ! The fourth column;
PTR ← CONLST:NEXT[PTR];
END;
MAKE_REMARK("String constants");
PTR ← STR_HDR;
WHILE PTR ≠ RNULL DO ! Emit strings;
BEGIN
INTEGER ADR;
EMIT(STRID,CONST); ! Header for typing;
EMIT(CONLST:LAB[PTR],SYMDEC);
ADR ← LOC(STCONST:VAL[CONLST:VAL[PTR]]);
EMIT(ADR,STRCONST);
PTR ← CONLST:NEXT[PTR];
END;
END "dump constants"
! EMITEXPR: expression;
! An expression?;
ELSE IF RTYPE = LOC(EXPRN)
THEN BEGIN "recurse"
INTEGER OPR;
OPR ← EXPRN:OP[XPRESS];
IF OPR < 0 ∨ OPR ≥ LAST_OP
THEN BEGIN
COMERR("Illegal expression",XPRESS);
DTYPE ← 0;
END
ELSE CASE OPR OF
BEGIN "case"
[NO_OP] DTYPE ← EMITEXPR(CELL:CAR[EXPRN:ARGS[XPRESS]]);
[SCALRD_OP] BEGIN
EMIT(SCALRD_PSOP,PSINST);
DTYPE ← SVAL_DTYPE
END;
[QUERY_OP] BEGIN
PRINT_LIST(EXPRN:ARGS[XPRESS]); ! Take care of any print items;
EMIT(QUERY_PSOP,PSINST);
DTYPE ← SVAL_DTYPE
END;
[SABS_OP] ONEARG(SVAL_DTYPE,SABS_PSOP,SVAL_DTYPE);
[SADD_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SADD_PSOP,SVAL_DTYPE);
[SNEG_OP] ONEARG(SVAL_DTYPE,SNEG_PSOP,SVAL_DTYPE);
[SSUB_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SSUB_PSOP,SVAL_DTYPE);
[SMUL_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SMUL_PSOP,SVAL_DTYPE);
[SDIV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SDIV_PSOP,SVAL_DTYPE);
[SEXP_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SEXP_PSOP,SVAL_DTYPE);
[MAX_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MAX_PSOP,SVAL_DTYPE);
[MIN_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MIN_PSOP,SVAL_DTYPE);
[INT_OP] ONEARG(SVAL_DTYPE,INT_PSOP,SVAL_DTYPE);
[DIV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,IDIV_PSOP,SVAL_DTYPE);
[MOD_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MOD_PSOP,SVAL_DTYPE);
[SLT_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SLT_PSOP,SVAL_DTYPE);
[SEQ_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SEQ_PSOP,SVAL_DTYPE);
[SLE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SLE_PSOP,SVAL_DTYPE);
[SGE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SGE_PSOP,SVAL_DTYPE);
[SNE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SNE_PSOP,SVAL_DTYPE);
[SGT_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SGT_PSOP,SVAL_DTYPE);
[AND_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,AND_PSOP,SVAL_DTYPE);
[OR_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,LOR_PSOP,SVAL_DTYPE);
[NOT_OP] ONEARG(SVAL_DTYPE,NOT_PSOP,SVAL_DTYPE);
[XOR_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,LXOR_PSOP,SVAL_DTYPE);
[EQV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,EQV_PSOP,SVAL_DTYPE);
[VMAGN_OP] ONEARG(V3ECT_DTYPE,VMAGN_PSOP,SVAL_DTYPE);
[VDOT_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VDOT_PSOP,SVAL_DTYPE);
[RMAGN_OP] ONEARG(ROTN_DTYPE,TMAGN_PSOP,SVAL_DTYPE);
[AXIS_OP] ONEARG(ROTN_DTYPE,TAXIS_PSOP,V3ECT_DTYPE);
[VMAKE_OP] THREEARGS(SVAL_DTYPE,SVAL_DTYPE,SVAL_DTYPE,VMAKE_PSOP,V3ECT_DTYPE);
[SVMUL_OP] TWOARGS(SVAL_DTYPE,V3ECT_DTYPE,SVMUL_PSOP,V3ECT_DTYPE);
[VSDIV_OP] TWOARGS(V3ECT_DTYPE,SVAL_DTYPE,VSDIV_PSOP,V3ECT_DTYPE);
[VADD_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VADD_PSOP,V3ECT_DTYPE);
[VSUB_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VSUB_PSOP,V3ECT_DTYPE);
[VCROSS_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VCROSS_PSOP,V3ECT_DTYPE);
[RVMUL_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TVMUL_PSOP,V3ECT_DTYPE);
[TVMUL_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVMUL_PSOP,V3ECT_DTYPE);
[UVECT_OP] ONEARG(V3ECT_DTYPE,UNITV_PSOP,V3ECT_DTYPE);
[POS_OP] ONEARG(TRANS_DTYPE,TPOS_PSOP,V3ECT_DTYPE);
[ORIENT_OP] ONEARG(TRANS_DTYPE,TORIEN_PSOP,ROTN_DTYPE);
[AXW_ROTN_OP] TWOARGS(V3ECT_DTYPE,SVAL_DTYPE,VSAXWR_PSOP,ROTN_DTYPE);
[TMAKE_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TMAKE_PSOP,TRANS_DTYPE);
[CONSTR_OP] THREEARGS(V3ECT_DTYPE,V3ECT_DTYPE,V3ECT_DTYPE,CONSTR_PSOP,TRANS_DTYPE);
[TVADD_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVADD_PSOP,TRANS_DTYPE);
[TVSUB_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVSUB_PSOP,TRANS_DTYPE);
[RRMUL_OP] TWOARGS(ROTN_DTYPE,ROTN_DTYPE,TTMUL_PSOP,ROTN_DTYPE);
[TTMUL_OP] TWOARGS(TRANS_DTYPE,TRANS_DTYPE,TTMUL_PSOP,TRANS_DTYPE);
[TINVRT_OP] ONEARG(TRANS_DTYPE,TINVRT_PSOP,TRANS_DTYPE);
[FTOF_OP] BEGIN ! A→B ≡ INV(A)*B;
ONEARG(TRANS_DTYPE,TINVRT_PSOP,TRANS_DTYPE);
IF EMITEXPR(CADR(EXPRN:ARGS[XPRESS])) ≠ TRANS_DTYPE
THEN COMERR("Wrong type for second argument",XPRESS);
EMIT(TTMUL_PSOP,PSINST);
END;
[FMAKE_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TMAKE_PSOP,TRANS_DTYPE);
[SSBRTN_OP] BEGIN
INTEGER OPTYPE;
IF (OPTYPE←SVAL:VAL[CELL:CAR[EXPRN:ARGS[XPRESS]]]) = ATAN2_OP
THEN BEGIN
MAKE_REMARK("second argument");
IF EMITEXPR(CADDR(EXPRN:ARGS[XPRESS])) ≠ SVAL_DTYPE
THEN COMERR("Wrong type of argument",XPRESS);
END;
MAKE_REMARK("first argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XPRESS])) ≠ SVAL_DTYPE
THEN COMERR("Wrong type of argument",XPRESS);
EMIT(SSBRTN_PSOP,PSINST);
MAKE_REMARK(
CASE OPTYPE-1 OF ("sqrt","sin","cos","tan","asin","acos",
"atan2","log","exp","time"));
EMIT(OPTYPE,CONST);
DTYPE ← SVAL_DTYPE;
END;
[AREF_OP] BEGIN
IF GET THEN
BEGIN
MAKE_REMARK("Array reference");
EMITSUBS(CELL:CDR[EXPRN:ARGS[XPRESS]]);
EMIT(GTVAL_PSOP,PSINST)
END;
EMITOFFSET(CELL:CAR[EXPRN:ARGS[XPRESS]]);
DTYPE ← ARRAYDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[XPRESS]]]
END;
[CALL_OP] DTYPE ← EMITCALL(XPRESS);
[VM_OP] BEGIN ! Vision Module call;
INTEGER N,I,J,K,DT;
RCELL C;
MAKE_REMARK("Vision Module call");
EMIT(VM_PSOP,PSINST);
C ← EXPRN:ARGS[XPRESS]; ! List of arguments;
N ← SVAL:VAL[CELL:CAR[C]];
EMIT(N,CONST); ! Command number;
FOR I ← 1 TIL 2 DO ! List of args & results;
BEGIN
N ← SVAL:VAL[CELL:CAR[(C←CELL:CDR[C])]];
EMIT(N,CONST); ! # of args;
FOR J ← 1 TIL N DO ! Type-Value pairs;
BEGIN
K ← SVAL:VAL[CELL:CAR[(C←CELL:CDR[C])]];
EMIT(K,CONST); ! Type;
DT ← EMITEXPR(CELL:CAR[(C←CELL:CDR[C])],FALSE); ! Value;
K ← IF K = 4 THEN STRNG_DTYPE ELSE SVAL_DTYPE;
IF K ≠ DT THEN
USERERR(0,1,"YIKES! Vision Module routines screwed up!!!");
END;
END;
DTYPE ← SVAL_DTYPE;
END;
[ADC_OP] BEGIN ! Read A/D channel;
INTEGER N;
IF RECTYPE(CELL:CAR[EXPRN:ARGS[XPRESS]])=LOC(SVAL) THEN
BEGIN ! Channel number is a constant;
N ← SVAL:VAL[CELL:CAR[EXPRN:ARGS[XPRESS]]];
IF N < 0 ∨ N > 63 THEN
BEGIN
USERERR(0,1,"Illegal A/D channel - will use channel 0");
N ← 0;
END
END
ELSE
BEGIN ! Evaluate channel number;
MAKE_REMARK("A/D channel");
EMITEXPR(CELL:CAR[EXPRN:ARGS[XPRESS]]);
N ← -1;
END;
MAKE_REMARK("Read A/D channel");
EMIT(ADC_PSOP,PSINST);
EMIT(N,OCONST); ! Channel number (-1 = on stack);
DTYPE ← SVAL_DTYPE;
END;
[INVALID_OP] COMERR("Invalid operator",XPRESS)
END "case";
IF DTYPE ≠ EXPRN:DATATYPE[XPRESS] ∧
( DTYPE ≠ TRANS_DTYPE ∨ EXPRN:DATATYPE[XPRESS] ≠ FRAME_DTYPE )
THEN COMERR("Type consistency error in EMITEXPR: " & CVS(DTYPE) &" ≠ " &
CVS(EXPRN:DATATYPE[XPRESS]) & ".",XPRESS);
END "recurse"
ELSE BEGIN
COMERR("Garbage expression",XPRESS);
DTYPE ← 0;
END;
IF DTYPE = FRAME_DTYPE THEN DTYPE ← TRANS_DTYPE;
RETURN(DTYPE);
END "emitexpr";
! EMITBOOL;
PROCEDURE EMITBOOL(REXPR CONDITION; INTEGER DESTTRUE (0), DESTFALSE (0));
BEGIN "emitbool"
! Generates code to evaluate the condition. If it succeeds,
there should be a jump to DESTTRUE, if false, to DESTFALSE. If
either is 0, instead of jumping there, fall through;
! modified by arg 9-14-76;
IF DESTFALSE
THEN BEGIN "fjump"
! Put the tested result on the stack;
IF EMITEXPR(CONDITION) ≠ SVAL_DTYPE
THEN COMERR("Non-scalar boolean",CONDITION);
EMIT(JUMPC_PSOP,PSINST); ! JUMPC;
EMIT(DESTFALSE,SYMREF); ! (ref) DESTFALSE;
IF DESTTRUE
THEN BEGIN "tfjump"
EMIT(JUMP_PSOP,PSINST); ! JUMP;
EMIT(DESTTRUE,SYMREF); ! (ref) DESTTRUE;
END "tfjump"
END "fjump"
ELSE IF DESTTRUE
THEN BEGIN "tjump"
! Put the tested result on the stack;
IF EMITEXPR(CONDITION) ≠ SVAL_DTYPE
THEN COMERR("Non-scalar boolean",CONDITION);
EMIT(NOT_PSOP,PSINST); ! Take the complement of the boolean;
EMIT(JUMPC_PSOP,PSINST); ! JUMPC;
EMIT(DESTTRUE,SYMREF); ! (ref) DESTTRUE;
END "tjump";
END "emitbool";
! ENV_SIZE;
RECURSIVE INTEGER PROCEDURE ENV_SIZE(RANY BLK);
BEGIN
INTEGER SIZE,S;
RANY P;
IF (S ← RECTYPE(BLK)) = LOC(STMNT) THEN
BEGIN
BLK ← STMNT:SEMANTICS[BLK];
IF BLK = RNULL THEN RETURN(0) ELSE S ← RECTYPE(BLK);
END;
IF S = LOC(BLOCK) THEN
BEGIN "blk"
SIZE ← 0;
P ← BLOCK:VARS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count algebraic vars;
P ← CELL:CDR[P] END;
P ← BLOCK:ARAYS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count arrays;
P ← CELL:CDR[P] END;
P ← BLOCK:EVTS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count events;
P ← CELL:CDR[P] END;
P ← BLOCK:CMONS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count cmons;
P ← CELL:CDR[P] END;
P ← BLOCK:PROCS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count procedures;
P ← CELL:CDR[P] END;
S ← 0;
P ← BLOCK:CODE[BLK];
WHILE P ≠ RNULL DO S ← S MAX ENV_SIZE(LLOP(P)); ! Check for nested blocks;
RETURN(SIZE+S);
END "blk"
ELSE IF S = LOC(FORR) THEN RETURN(ENV_SIZE(FORR:BODY[BLK]))
ELSE IF S = LOC(WHIL) THEN RETURN(ENV_SIZE(WHIL:BODY[BLK]))
ELSE IF S = LOC(UNTL) THEN RETURN(ENV_SIZE(UNTL:BODY[BLK]))
ELSE IF S = LOC(IFF) THEN
RETURN(ENV_SIZE(IFF:THN[BLK]) MAX ENV_SIZE(IFF:ELS[BLK]))
ELSE IF S = LOC(KASE) THEN
BEGIN
S ← 0;
P ← KASE:STMNTS[BLK];
WHILE P≠RNULL DO S ← S MAX ENV_SIZE(LLOP(P)); ! check for nested blocks;
RETURN(S)
END
ELSE RETURN(0);
END;
! TSCAN: STMNT, PROG;
INTEGER OFS; ! The current offset for variables;
INITIALIZE (OFS ← '400); ! Level 1, offset 0;
INTEGER RETRY_LAB; ! Label for retrying moves;
INTERNAL RECURSIVE PROCEDURE TSCAN (RANY PARSETREE);
BEGIN "tscan"
! TSCAN takes a parse tree and interprets its nodes, calling
appropriate routines to prepare code for each node;
INTEGER STYP, ! Statement type;
LAB1, LAB2, LAB3, LAB4;
! Save labels across recursive calls. Cannot
save in DATA since that is an OWN array;
RPTR(STMNT) STATEMENT;
LABEL MIDLABEL, ENDLABEL; ! This is to prevent parse stack overflow;
STYP ← RECTYPE(PARSETREE);
IF STYP = LOC(STMNT) THEN
BEGIN "stmnt"
! Eventually will want to output labelling information here;
STATEMENT ← PARSETREE;
PARSETREE ← STMNT:SEMANTICS[PARSETREE];
IF PARSETREE = RNULL THEN RETURN;
STYP ← RECTYPE(PARSETREE);
END "stmnt";
IF STYP = LOC(VARIABLE) THEN
! Just ignore it. Variable declarations are treated with
block entry and exit;
ELSE IF STYP = LOC(NOTE) THEN
PRINT(STCONST:VAL[NOTE:HESAYS[PARSETREE]],CRLF)
ELSE IF STYP = LOC(PROG) THEN
BEGIN "prog"
MAKE_REMARK("Start of program");
EMIT(PROG_PSOP,PSINST); ! Make mechanism variables;
LAB4 ← ENV_SIZE(PROG:CODE[PARSETREE]);
EMIT(LAB4,CONST); ! Environment size needed by program;
MAKE_REMARK("Initialization - AFFIX driver_grasp to driver_tip");
EMITEXPR(NEW_TRANS(NILROTN,SVMUL(1.875,ZHAT)));
EMIT(AFFIX_PSOP,PSINST);
EMITOFFSET(DR_TIP);
EMITOFFSET(DR_GRASP);
EMIT('2000,OCONST); ! Explicitly named trans, rigid affixment, value on stack;
EMITOFFSET(DR_TRANS);
MAKE_REMARK("Init (cont) - AFFIX moving_jaw to fixed_jaw");
MAKE_REMARK(" Wait till VISE is ready");
! EMITEXPR(NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(VISE,YHAT)) )) );
! EMIT(AFFIX_PSOP,PSINST);
! EMITOFFSET(MOVING_JAW);
! EMITOFFSET(FIXED_JAW);
! EMIT('2000,OCONST); ! Explicitly named trans, rigid affixment, value on stack;
! EMITOFFSET(VISE_OPENING);
MAKE_REMARK("End of Initialization");
TSCAN(PROG:CODE[PARSETREE]);
EMIT(ENDP_PSOP,PSINST); ! Clean up mechanism variables;
MAKE_REMARK("End of program");
MAKE_REMARK("Program constants");
EMITEXPR(PARSETREE); ! Now write out the constant values;
END "prog"
! TSCAN: BLOCK;
ELSE IF STYP = LOC(BLOCK) THEN
BEGIN "block"
RCELL C; ! Holds variable list and current tail of block;
INTEGER DUMY, COFS, SAVOFS; ! Holds OFS for the duration;
INTEGER CNT, CTYPE, T, BITS;
RVAR VARBL; ! Temporary: variable under consideration;
RANY F,P;
RPTR(CMON) MONITOR; ! Temporary: cmon under consideration;
RCLASS COLAB (INTEGER LBEL; RPTR(COLAB) NEXT);
RPTR (COLAB) LABELS, HERE;
INTEGER PROCEDURE TYPE_GET(INTEGER DTYPE);
CASE DTYPE OF
BEGIN
[SVAL_DTYPE] RETURN(SCLID);
[V3ECT_DTYPE] RETURN(VCTID);
[ROTN_DTYPE] [TRANS_DTYPE] [FRAME_DTYPE] RETURN(TRNID);
[EVENT_DTYPE] RETURN(EVTID);
[STRNG_DTYPE] RETURN(STRID);
ELSE RETURN(0)
END;
INTEGER PROCEDURE VAR_CNT(INTEGER DTYPE);
BEGIN ! Count & assign offsets to all variables of specified type;
INTEGER CNT;
C ← BLOCK:VARS[PARSETREE];
CNT ← 0;
WHILE C ≠ RNULL DO
BEGIN
VARBL ← LLOP(C);
IF VARIABLE:DATATYPE[VARBL] = DTYPE THEN
BEGIN
CNT ← CNT + 1;
VARIABLE:OFFSET[VARBL] ← OFS;
EMITSYM(VARBL);
OFS ← OFS + 1;
END;
END;
RETURN(CNT)
END;
MAKE_REMARK("BLOCK");
SAVOFS ← OFS; ! We will assign new offsets in this block.;
IF BLOCK:VARS[PARSETREE] ≠ RNULL ∨ BLOCK:ARAYS[PARSETREE] ≠ RNULL ∨
BLOCK:EVTS[PARSETREE] ≠ RNULL ∨ BLOCK:PROCS[PARSETREE] ≠ RNULL ∨
BLOCK:CMONS[PARSETREE] ≠ RNULL THEN BEGIN "make some variables"
! Emit code to compute any array bounds expressions;
C ← BLOCK:ARAYS[PARSETREE];
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get array header;
FOR CNT ← 1 TIL ARRAYDEF:NUMDIMS[F] DO
FOR T ← 0 TIL 1 DO
IF RECTYPE(ARRAYDEF:BOUNDS[F][CNT,T]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Array bounds expression");
EMITEXPR(ARRAYDEF:BOUNDS[F][CNT,T]);
EMIT(CHNGE_PSOP,PSINST);
EMITOFFSET(ARRAYDEF:BOUNDS[F][CNT,T+2])
END
END;
! Declare variables;
EMIT(MVAR_PSOP,PSINST); ! variable declaration;
IF (T ← VAR_CNT(SVAL_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK("Scalars");
EMIT(SCLID,CONST);
EMIT(T,CONST);
END;
IF (T ← VAR_CNT(V3ECT_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK("Vectors");
EMIT(VCTID,CONST);
EMIT(T,CONST);
END;
IF (T←VAR_CNT(ROTN_DTYPE)+VAR_CNT(TRANS_DTYPE)+VAR_CNT(FRAME_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK("Transes");
EMIT(TRNID,CONST);
EMIT(T,CONST);
END;
IF (T ← VAR_CNT(STRNG_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK("Strings");
EMIT(STRID,CONST);
EMIT(T,CONST);
END;
! Declare the arrays;
C ← BLOCK:ARAYS[PARSETREE];
IF C ≠ RNULL THEN MAKE_REMARK("Arrays");
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get the array header;
MAKE_REMARK(ARRAYDEF:NAME[F]);
ARRAYDEF:OFFSET[F] ← OFS;
EMITSYM(F);
OFS ← OFS + 1;
T ← TYPE_GET(ARRAYDEF:DATATYPE[F]) + ARYID;
EMIT(T,OCONST); ! Emit the datatype;
EMIT(ARRAYDEF:NUMDIMS[F],CONST);
FOR CNT ← 1 TIL ARRAYDEF:NUMDIMS[F] DO
FOR T ← 1 STEP -1 UNTIL 0 DO
BEGIN
P ← ARRAYDEF:BOUNDS[F][CNT,T];
IF RECTYPE(P)=LOC(EXPRN) THEN P←ARRAYDEF:BOUNDS[F][CNT,T+2];
IF RECTYPE(P)=LOC(VARIABLE) THEN EMITOFFSET(P)
ELSE
BEGIN
BITS ← SVAL:VAL[P]; ! Convert constant bound to integer;
BITS ← BITS LOR '100000; ! Set sign bit for constants;
EMIT(BITS,OCONST)
END
END
END;
! Declare the events;
C ← BLOCK:EVTS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN
MAKE_REMARK("Events");
CNT ← 0;
WHILE C ≠ RNULL DO
BEGIN ! Count the events;
VARBL ← LLOP(C);
CNT ← CNT + 1;
VARIABLE:OFFSET[VARBL] ← OFS;
EMITSYM(VARBL);
OFS ← OFS + 1;
END;
EMIT(EVTID,CONST);
EMIT(CNT,CONST);
END;
! Declare each condition monitor;
DEFINE EV_CM = 0; ! event;
DEFINE EXP_CM = 1; ! expression or variable;
DEFINE DUR_CM = 2; ! duration;
DEFINE FORCE_CM = 3; ! force sensing;
DEFINE HARDW_CM = 4; ! hardware monitoring;
! Here's what the various types of condition monitors look like:
for all: (dec) LAB: "condition monitor checker"
for events: CMSKED, CMWAIT <offset>, CMTRIG
for variables & expressions: CMSKED, <time: 100>,
<code for boolean condition>, JUMPC LAB, CMTRIG,
for durations: <code to get time to wait>, CMDUR,
for force sensing: <<code to get force vect>,VMKFRC> or <code to get
force frame>, TMKFRC, <control frame>, <coordinate bits>
<code to get force value>, CMFORCE, <control frame>
for hardware monitoring: CMSENSE,
for everyone: <code for conclusion>,
for events and variables & expressions: JUMP (ref) LAB,
for the rest: CMDONE,
In the cmon section of MVAR:
for everyone: <type>, (ref) LAB2, <environment size required>,
for force sensing and hardware monitoring: <bits>;
C ← BLOCK:CMONS[PARSETREE];
CNT ← 0;
HERE ← LABELS ← NEW_RECORD (COLAB);
WHILE C ≠ RNULL DO ! Assign an offset & label to each cmon;
BEGIN
MONITOR ← LLOP(C);
CNT ← CNT + 1;
CMON:OFFSET[MONITOR] ← OFS;
COLAB:LBEL[HERE] ← GENLABEL;
HERE ← COLAB:NEXT[HERE] ← NEW_RECORD(COLAB);
OFS ← OFS + 1;
END;
C ← BLOCK:CMONS[PARSETREE];
IF C ≠ RNULL THEN ! Declare the cmons;
BEGIN
MAKE_REMARK("Cmons");
EMIT(CMNID,CONST);
EMIT(CNT,CONST);
HERE ← LABELS;
WHILE C ≠ RNULL DO ! Info for CMMAK;
BEGIN "cmdcl"
MONITOR ← LLOP(C);
CTYPE ← IF (T←RECTYPE(CMON:CONDITION[MONITOR])) = LOC(VARIABLE) ∧
VARIABLE:DATATYPE[CMON:CONDITION[MONITOR]] = EVENT_DTYPE THEN EV_CM
ELSE IF T=LOC(EXPRN) ∧ EXPRN:OP[CMON:CONDITION[MONITOR]]=AREF_OP
∧ ARRAYDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[CMON:CONDITION[MONITOR]]]]
= EVENT_DTYPE THEN EV_CM
ELSE IF T = LOC(VARIABLE) ∨ T = LOC(EXPRN) THEN EXP_CM
ELSE IF T = LOC(DURATION) THEN DUR_CM
ELSE IF T = LOC(FORCE) THEN FORCE_CM
ELSE HARDW_CM;
EMIT(CTYPE,CONST); ! Tell what type of cmon it is;
EMIT(COLAB:LBEL[HERE],SYMREF); ! Tell where the cmon starts;
HERE ← COLAB:NEXT[HERE];
T ← ENV_SIZE(CMON:CONCLUSION[MONITOR]);
EMIT(T,CONST); ! How large an environment it will need;
IF CTYPE = FORCE_CM THEN ! What frcsig needs to know;
BEGIN ! Figure out the bits;
F ← CMON:CONDITION[MONITOR];
BITS ← FORCE:REL[F] + (IF FORCE:DIRECT[F] = ZHAT THEN ZFORCE ELSE
IF FORCE:DIRECT[F] = YHAT THEN YFORCE ELSE XFORCE);
IF ¬FORCE:TYPE[F] THEN BITS ← BITS + XMOMENT; ! It's a torque;
IF CMON:FLAGS[MONITOR] LAND FSTOP THEN BITS ← BITS + FSTOP;
EMIT(BITS,OCONST);
END
! ELSE IF CTYPE = HARDW_CM THEN who knows what we need to do;
END "cmdcl";
END;
! Declare the procedures;
C ← BLOCK:PROCS[PARSETREE];
CNT ← 0;
WHILE C ≠ RNULL DO ! Assign an offset & a label to each procedure;
BEGIN
CNT ← CNT + 1;
F ← LLOP(C);
PROCDEF:OFFSET[F] ← OFS;
PROCDEF:LAB[F] ← GENLABEL;
OFS ← OFS + 1
END;
C ← BLOCK:PROCS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN
MAKE_REMARK("Procedures");
EMIT(PROID,OCONST);
EMIT(CNT,CONST);
END;
WHILE C ≠ RNULL DO ! Emit the procedure header info;
BEGIN
F ← LLOP(C);
MAKE_REMARK(PROCDEF:NAME[F]);
EMIT(PROCDEF:NUMARGS[F],CONST);
EMIT(PROCDEF:LAB[F],SYMREF); ! Start of procedure's body;
T ← ENV_SIZE(PROCDEF:BODY[F]);
EMIT(T,CONST);
F ← PROCDEF:ARGS[F];
WHILE F ≠ RNULL DO
BEGIN
P ← LLOP(F);
IF RECTYPE(P) = LOC(VARIABLE) THEN
T ← TYPE_GET(VARIABLE:DATATYPE[P]) +
! May want to change this if VALUE becomes the default;
(IF VALARG_ON(VARIABLE:ATTRIBUTES[P]) THEN 0 ELSE REFID)
ELSE T ← TYPE_GET(ARRAYDEF:DATATYPE[P]) + ARYID + REFID;
EMIT(T,OCONST)
END
END;
EMIT(0,CONST); ! End MVAR with a zero;
! TSCAN: BLOCK continued;
C ← BLOCK:CMONS[PARSETREE]; ! Emit code for each cmon;
IF C ≠ RNULL THEN
BEGIN "cmmak"
LAB1 ← GENLABEL;
EMIT(JUMP_PSOP,PSINST); ! Jump past cmon bodies;
EMIT(LAB1,SYMREF);
MAKE_REMARK("Condition monitors");
COFS ← OFS;
HERE ← LABELS;
WHILE C ≠ RNULL DO
BEGIN "blkcmon"
MONITOR ← LLOP(C);
OFS ← (COFS LAND '17400) + '400;! Move to next lexical level, offset 0;
CTYPE ← IF (T←RECTYPE(CMON:CONDITION[MONITOR])) = LOC(VARIABLE) ∧
VARIABLE:DATATYPE[CMON:CONDITION[MONITOR]] = EVENT_DTYPE THEN EV_CM
ELSE IF T=LOC(EXPRN) ∧ EXPRN:OP[CMON:CONDITION[MONITOR]]=AREF_OP
∧ ARRAYDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[CMON:CONDITION[MONITOR]]]]
= EVENT_DTYPE THEN EV_CM
ELSE IF T = LOC(VARIABLE) ∨ T = LOC(EXPRN) THEN EXP_CM
ELSE IF T = LOC(DURATION) THEN DUR_CM
ELSE IF T = LOC(FORCE) THEN FORCE_CM
ELSE HARDW_CM;
MAKE_REMARK("Condition monitor checker");
EMIT(COLAB:LBEL[HERE],SYMDEC); ! Cmon start address;
CASE CTYPE OF BEGIN "c-m checker"
[EV_CM] BEGIN "cmevt" ! An event to wait for;
EMIT(CMSKED_PSOP,PSINST);
MAKE_REMARK("Event cmon");
IF RECTYPE(CMON:CONDITION[MONITOR]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for event var");
EMITSUBS(CELL:CDR[EXPRN:ARGS[CMON:CONDITION[MONITOR]]])
END;
EMIT(CMWAIT_PSOP,PSINST);
EMITOFFSET(CMON:CONDITION[MONITOR]);
EMIT(CMTRIG_PSOP,PSINST);
END "cmevt";
[EXP_CM] BEGIN "cmexpr" ! An expression to be evaluated;
EMIT(CMSKED_PSOP,PSINST);
EMIT(100,CONST); ! Waiting interval;
EMITBOOL(CMON:CONDITION[MONITOR],0,COLAB:LBEL[HERE]);
EMIT(CMTRIG_PSOP,PSINST);
END "cmexpr";
[DUR_CM] BEGIN "cmdur" ! A duration to wait for;
EMITEXPR(DURATION:TIME[CMON:CONDITION[MONITOR]]); ! Get the time;
EMIT(CMDUR_PSOP,PSINST);
END "cmdur";
[FORCE_CM] BEGIN "cmforce" ! A force to wait for;
F ← CMON:CONDITION[MONITOR];
IF FORCE:DIRECT[F] ≠ XHAT ∧ FORCE:DIRECT[F] ≠ YHAT
∧ FORCE:DIRECT[F]≠ZHAT THEN
BEGIN ! Need to make force frame;
EMITEXPR(FORCE:DIRECT[F]); ! Get force vector;
EMIT(VMKFRC_PSOP,PSINST); ! Make up force frame;
EMIT(TFRCST_PSOP,PSINST); ! Set it up;
EMITOFFSET(FORCE:CF[F]); ! Control frame;
DUMY ← FTABLE;
EMIT(DUMY,OCONST); ! Bits for SETC;
END
ELSE IF FORCE:F_F[F] ≠ RNULL THEN
BEGIN ! Need to set up force frame;
EMITEXPR(F_FRAME:FRAME[FORCE:F_F[F]]); ! Get force frame;
EMIT(TFRCST_PSOP,PSINST); ! Set it up;
EMITOFFSET(FORCE:CF[F]); ! Control frame;
EMIT(F_FRAME:C_SYS[FORCE:F_F[F]],OCONST); ! Bits for SETC;
END;
EMITEXPR(FORCE:VAL[F]); ! Get force value;
EMIT(CMFORCE_PSOP,PSINST);
EMITOFFSET(FORCE:CF[F]); ! Control frame;
END "cmforce";
[HARDW_CM] EMIT(CMSENSE_PSOP,PSINST)
END "c-m checker";
TSCAN(CMON:CONCLUSION[MONITOR]);
IF CTYPE = EV_CM ∨ CTYPE = EXP_CM THEN
BEGIN
EMIT(JUMP_PSOP,PSINST);
EMIT(COLAB:LBEL[HERE],SYMREF); ! Cmon start address;
END
ELSE EMIT(CMDONE_PSOP,PSINST);
HERE ← COLAB:NEXT[HERE];
END "blkcmon";
EMIT(LAB1,SYMDEC); ! So we can jump past the code for cmons;
OFS ← COFS; ! Restore lexical level;
END "cmmak";
! Make the procedure bodies local to this block;
C ← BLOCK:PROCS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN "proc make"
LAB1 ← GENLABEL;
EMIT(JUMP_PSOP,PSINST); ! Jump past procedure bodies;
EMIT(LAB1,SYMREF);
MAKE_REMARK("Procedures bodies");
COFS ← OFS;
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get procedure header;
OFS ← (COFS LAND '17400) + '400;! Move to next lexical level, offset 0;
EMIT(PROCDEF:LAB[F],SYMDEC);
MAKE_REMARK(PROCDEF:NAME[F]);
P ← PROCDEF:ARGS[F];
WHILE P ≠ RNULL DO
BEGIN ! Assign offsets to procedure arguments;
VARIABLE:OFFSET[CELL:CAR[P]] ← OFS;
OFS ← OFS + 1;
EMITSYM(LLOP(P)) ! Who knows what ALAID will do with them;
END;
P ← BLOCK:CODE[STMNT:SEMANTICS[PROCDEF:BODY[F]]];
WHILE P ≠ RNULL DO ! Generate code for the stmnts in the procedure;
TSCAN(LLOP(P));
CASE PROCDEF:DATATYPE[F] OF
BEGIN ! Make sure typed procedures return something;
[0] ; ! Not typed so don't bother putting anything on the stack;
[SVAL_DTYPE] EMITEXPR(FALSEV);
[V3ECT_DTYPE] EMITEXPR(NILVECT);
[STRNG_DTYPE] EMITEXPR(NEW_RECORD(STCONST)); ! Null string;
ELSE EMITEXPR(NILTRANS)
END;
EMIT(RETURN_PSOP,PSINST);
IF PROCDEF:DATATYPE[F]=0 THEN EMIT(0,OCONST)
ELSE EMIT(-1,OCONST);
END;
EMIT(LAB1,SYMDEC);
OFS ← COFS ! Restore lexical level;
END "proc make"
END "make some variables";
! Generate the code for the statements in the block;
C ← BLOCK:CODE[PARSETREE];
WHILE C ≠ RNULL DO
TSCAN(LLOP(C));
IF (T ← (OFS - SAVOFS) LAND '377) THEN
BEGIN
MAKE_REMARK("Block end cleanup");
EMIT(KVAR_PSOP,PSINST); ! Kill all the variables we made;
EMIT(T,CONST);
OFS ← SAVOFS; ! Restore the offset to original state;
END;
MAKE_REMARK("End of BLOCK");
END "block"
! TSCAN: COBLOCK;
ELSE IF STYP = LOC(COBLOCK) THEN
BEGIN "coblock"
RCLASS COLAB (INTEGER LBEL; RPTR(COLAB) NEXT);
RPTR (COLAB) LABELS, HERE;
INTEGER SAVOFS; ! Holds OFS for the duration;
RCELL C;
PRELOAD_WITH JUMP_PSOP, DUMMY, ! 1-2;
SPROUT_PSOP, DUMMY, ! 3-4;
TERMINATE_PSOP, ! 5;
DUMMY; ! 6;
INTEGER OWN ARRAY DATA[1:6];
PRELOAD_WITH PSINST, SYMREF, ! 1-2;
PSINST, SYMREF, ! 3-4;
PSINST, ! 5;
SYMDEC; ! 6;
INTEGER OWN ARRAY RELOC[1:6];
HERE ← LABELS ← NEW_RECORD (COLAB);
LAB1 ← DATA[2] ← GENLABEL;
MAKE_REMARK("Coblock");
EMIT(DATA[1],RELOC[1],2); ! Jump to end label;
SAVOFS ← OFS;
OFS ← (OFS LAND '17400) + '400; ! Move to next lexical level, offset 0;
C ← COBLOCK:CODE[PARSETREE];
WHILE C ≠ RNULL DO
BEGIN "onecob"
HERE ← COLAB:NEXT[HERE] ← NEW_RECORD(COLAB);
DATA[6] ← COLAB:LBEL[HERE] ← GENLABEL;
EMIT(DATA[6],RELOC[6]); ! symdec;
MAKE_REMARK(" Costatement");
TSCAN(LLOP(C));
EMIT(DATA[5],RELOC[5]); ! Terminate;
END "onecob";
OFS ← SAVOFS; ! Back to previous level;
DATA[6] ← LAB1; ! Label for jump around cocode;
EMIT(DATA[6],RELOC[6]); ! symdec;
HERE ← COLAB:NEXT[LABELS];
C ← COBLOCK:CODE[PARSETREE];
MAKE_REMARK(" epilog of Coblock");
EMIT(DATA[3],RELOC[3]); ! Sprout;
WHILE HERE ≠ RNULL DO
BEGIN
DATA[4] ← COLAB:LBEL[HERE];
EMIT(DATA[4],RELOC[4]); ! Label of code;
LAB4 ← ENV_SIZE(LLOP(C));
EMIT(LAB4,CONST); ! Environment size needed;
HERE ← COLAB:NEXT[HERE];
END;
EMIT(0,CONST); ! Final zero;
MAKE_REMARK("END COBLOCK");
END "coblock"
! TSCAN: FORR, WHIL, UNTL, IFF, CASE, PAUSE, PROMPT, ABORT;
ELSE IF STYP = LOC(FORR) THEN
BEGIN "forr"
! This is how it looks: [FOR LOOP] <stack initial, final, step>
LAB1: {push subscripts for control variable, if any}
XFORCHK <control variable> LAB2 <body> XFOREND LAB1 LAB2: [END FOR];
MAKE_REMARK("FOR LOOP");
EMITEXPR(FORR:INITIAL[PARSETREE]);
! This will emit code for the calculation of the initial
value;
EMITEXPR(FORR:FINAL[PARSETREE]);
! This will emit code for the calculation of the final
value;
EMITEXPR(FORR:STEP[PARSETREE]);
! This will emit code for the calculation of the step
value;
LAB1 ← GENLABEL; ! Top of loop;
LAB2 ← GENLABEL; ! End of loop;
EMIT(LAB1,SYMDEC);
IF RECTYPE(FORR:CONVAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
RCELL C;
MAKE_REMARK("Array reference");
C ← EXPRN:ARGS[FORR:CONVAR[PARSETREE]];
EMITSUBS(CELL:CDR[C])
END;
EMIT(FORCHK_PSOP,PSINST);
IF RECTYPE(FORR:CONVAR[PARSETREE]) = LOC(EXPRN) THEN
EMITOFFSET(CELL:CAR[EXPRN:ARGS[FORR:CONVAR[PARSETREE]]])
ELSE EMITOFFSET(FORR:CONVAR[PARSETREE]);
EMIT(LAB2,SYMREF);
TSCAN(FORR:BODY[PARSETREE]);
EMIT(FOREND_PSOP,PSINST);
EMIT(LAB1,SYMREF);
EMIT(LAB2,SYMDEC);
MAKE_REMARK("END FOR");
END "forr"
ELSE IF STYP = LOC(WHIL) THEN
BEGIN "while"
MAKE_REMARK("WHILE Loop");
LAB1 ← GENLABEL; ! Loop head;
LAB2 ← GENLABEL; ! After end;
EMIT(LAB1,SYMDEC); ! (dec) LAB1: ;
EMITBOOL(WHIL:COND[PARSETREE],0,LAB2);
TSCAN(WHIL:BODY[PARSETREE]);
! JUMP (ref) LAB1, (dec) LAB2: ;
EMIT(JUMP_PSOP,PSINST);
EMIT(LAB1,SYMREF);
EMIT(LAB2,SYMDEC);
MAKE_REMARK("END WHILE");
END "while"
ELSE IF STYP = LOC(UNTL) THEN
BEGIN "until"
MAKE_REMARK("DO UNTIL Loop");
LAB1 ← GENLABEL; ! Loop head;
EMIT(LAB1,SYMDEC); ! (dec) LAB1: ;
TSCAN(UNTL:BODY[PARSETREE]); ! Loop body;
EMITBOOL(UNTL:COND[PARSETREE],0,LAB1); ! Exit test;
MAKE_REMARK("END DO UNTIL");
END "until"
ELSE IF STYP = LOC(IFF) THEN
BEGIN "iff"
MAKE_REMARK("IF");
LAB1 ← GENLABEL; ! The head of the ELSE part;
LAB2 ← GENLABEL; ! At the end of the IF;
EMITBOOL(IFF:COND[PARSETREE],0,LAB1);
MAKE_REMARK("THEN");
TSCAN(IFF:THN[PARSETREE]);
IF STMNT:SEMANTICS[IFF:ELS[PARSETREE]] ≠ NULL THEN
BEGIN
! JUMP (ref) LAB2, (dec) LAB1: ;
EMIT(JUMP_PSOP,PSINST);
EMIT(LAB2,SYMREF);
END;
EMIT(LAB1,SYMDEC);
IF STMNT:SEMANTICS[IFF:ELS[PARSETREE]] ≠ NULL THEN
BEGIN
MAKE_REMARK("ELSE");
TSCAN(IFF:ELS[PARSETREE]);
EMIT(LAB2,SYMDEC); ! (dec) LAB2: ;
END;
MAKE_REMARK("FI");
END "iff"
ELSE IF STYP = LOC(KASE) THEN
BEGIN "case"
RCELL C;
INTEGER S,I,N;
MAKE_REMARK("CASE");
EMITEXPR(KASE:INDEX[PARSETREE]); ! Get the case index on the stack;
N ← KASE:RANGE[PARSETREE];
S ← KASE:NSTMNTS[PARSETREE];
EMIT(CASE_PSOP,PSINST);
EMIT(N,CONST); ! Max index value (+1) or -max if ELSE given;
FOR I ← 0 TIL S DO ! Assign labels to each statement;
KASE:LABS[PARSETREE][I,1] ← GENLABEL;
LAB1 ← KASE:LABS[PARSETREE][S,1];
IF N ≥ 0 THEN KASE:LABS[PARSETREE][N,1] ← LAB1 ELSE N ← ABS N;
! So null statements jump to right place;
FOR I ← 0 TIL N DO ! Make dispatch table;
EMIT(KASE:LABS[PARSETREE][KASE:LABS[PARSETREE][I,0],1],SYMREF);
C ← KASE:STMNTS[PARSETREE];
FOR I ← 0 TIL S-1 DO ! Now emit the labelled statements;
BEGIN
EMIT(KASE:LABS[PARSETREE][I,1],SYMDEC);
TSCAN(LLOP(C));
IF I ≠ S-1 THEN
BEGIN ! A slight optimization(?);
EMIT(JUMP_PSOP,PSINST); ! Jump to next statement;
EMIT(LAB1,SYMREF)
END
END;
EMIT(LAB1,SYMDEC)
END "case"
ELSE IF STYP = LOC(PAUSE) THEN
BEGIN "pause"
MAKE_REMARK("PAUSE");
! Get the value on the stack;
EMITEXPR(PAUSE:VAL[PARSETREE]);
EMIT(PAUSE_PSOP,PSINST);
END "pause"
ELSE IF STYP = LOC(PROMPT) THEN
BEGIN "prompt"
MAKE_REMARK("PROMPT");
PRINT_LIST(PROMPT:VAL[PARSETREE]); ! Take care of any print items;
EMIT(PROMPT_PSOP,PSINST);
END "prompt"
ELSE IF STYP = LOC(ABORT) THEN
BEGIN "abort"
MAKE_REMARK("ABORT");
EMIT(ABORT_PSOP,PSINST);
PRINT_LIST(ABORT:VAL[PARSETREE]); ! Take care of print items;
MAKE_REMARK("DDT"); ! Control passes to DDT;
EMIT(DDT_PSOP,PSINST);
END "abort"
ELSE GO TO MIDLABEL;
GO TO ENDLABEL; ! This is to avoid parse stack overflow;
! TSCAN: ASSIGNMENT, S_FAC, PRNT, CALL, RETURN, TOVAL, DAC;
MIDLABEL: ! Necessary to avoid parse stack overflow;
IF STYP = LOC(ASSIGNMENT) THEN
BEGIN "assignment"
MAKE_REMARK("Assignment");
! Get the value on the stack;
EMITEXPR(ASSIGNMENT:VAL[PARSETREE]);
! Emit "change variable to value on stack";
IF RECTYPE(ASSIGNMENT:VAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
RCELL C;
MAKE_REMARK("Array reference");
C ← EXPRN:ARGS[ASSIGNMENT:VAR[PARSETREE]];
EMITSUBS(CELL:CDR[C]);
EMIT(CHNGE_PSOP,PSINST);
EMITOFFSET(CELL:CAR[C])
END
ELSE
BEGIN
EMIT(CHNGE_PSOP,PSINST);
EMITOFFSET(ASSIGNMENT:VAR[PARSETREE])
END
END "assignment"
ELSE IF STYP = LOC(S_FAC) THEN
BEGIN "speed-factor"
MAKE_REMARK("Speed-factor Assignment");
EMITEXPR(S_FAC:VAL[PARSETREE]); ! Get the value on the stack;
EMIT(CHNGE_PSOP,PSINST); ! Emit "change speed-fac to value on stack";
EMITOFFSET(SPEED_FACTR);
END "speed-factor"
ELSE IF STYP = LOC(PRNT) THEN
PRINT_LIST(PRNT:VAL[PARSETREE]) ! Take care of print items;
ELSE IF STYP = LOC(EXPRN) THEN
BEGIN "procedure call"
EMITCALL(PARSETREE);
IF PROCDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[PARSETREE]]] ≠ 0 THEN
EMIT(POP_PSOP,PSINST) ! Flush value procedure returned;
END
ELSE IF STYP = LOC(RETRN) THEN
BEGIN "procedure return"
MAKE_REMARK("Return");
IF RETRN:VAL[PARSETREE] ≠ RNULL THEN
EMITEXPR(RETRN:VAL[PARSETREE]);
EMIT(RETURN_PSOP,PSINST);
IF RETRN:VAL[PARSETREE] ≠ RNULL THEN EMIT(-1,OCONST)
ELSE EMIT(0,OCONST);
END
ELSE IF STYP = LOC(TOVAL) THEN
BEGIN "command for PUMA"
MAKE_REMARK("VAL command");
EMIT(TOVAL_PSOP,PSINST);
EMITEXPR(TOVAL:HESAYS[PARSETREE],FALSE);
EMIT(TOVAL:WAIT[PARSETREE],CONST);
END
ELSE IF STYP = LOC(DAC) THEN
BEGIN ! Write D/A channel;
INTEGER N;
MAKE_REMARK("Write D/A channel");
EMITEXPR(DAC:VAL[PARSETREE]); ! Evaluate value to write;
IF RECTYPE(DAC:CHAN[PARSETREE])=LOC(SVAL) THEN
BEGIN ! Channel number is a constant;
N ← SVAL:VAL[DAC:CHAN[PARSETREE]];
IF N < 1 ∨ N > 4 THEN
BEGIN
USERERR(0,1,"Illegal D/A channel - will use channel 1");
N ← 1;
END
END
ELSE
BEGIN ! Evaluate channel number;
MAKE_REMARK("D/A channel");
EMITEXPR(DAC:CHAN[PARSETREE]);
N ← -1;
END;
EMIT(DAC_PSOP,PSINST);
EMIT(N,OCONST); ! Channel number (-1 = on stack);
END
! TSCAN: CMON, CMABLE;
ELSE IF STYP = LOC(CMON) THEN
BEGIN
IF ¬DEFER_ON(CMON:FLAGS[PARSETREE]) THEN
BEGIN "cmon"
MAKE_REMARK("Enable condition monitor");
EMIT(CMENBL_PSOP,PSINST);
EMIT(CMON:OFFSET[PARSETREE],OCONST);
END "cmon"
END
ELSE IF STYP = LOC(CMABLE) THEN
BEGIN "cmable"
RPTR(CMON,LBLVAR) CMONV; ! The CMON;
CMONV ← CMABLE:WHAT[PARSETREE];
IF RECTYPE(CMONV) = LOC(LBLVAR)
THEN CMONV ← LBLVAR:SEMANTICS[CMONV];
IF CMABLE:FLAG[PARSETREE]
THEN BEGIN "disable"
MAKE_REMARK("Disable");
EMIT(CMDSBL_PSOP,PSINST); ! CMDSBL (offset);
EMIT(CMON:OFFSET[CMONV],OCONST);
END "disable"
ELSE BEGIN "enable"
MAKE_REMARK("Enable");
EMIT(CMENBL_PSOP,PSINST); ! CMENBL (offset);
EMIT(CMON:OFFSET[CMONV],OCONST);
END "enable"
END "cmable"
! TSCAN: MOVE$;
ELSE IF STYP = LOC(MOVE$) THEN
BEGIN "move"
RPTR(APPROACH) APR; ! Approach clause (if any);
RPTR(DEPARTURE) DEP; ! Departure clause (if any);
RPTR(WOBBLE) WOB; ! Wobble clause (if any);
RPTR(S_FAC) SPD; ! Speed-factor clause (if any);
RPTR(DURATION) DUR; ! Duration clause (if any);
RCELL CLAUS,VIAL; ! The list of clauses & list of via points;
INTEGER BITS,NSEGS,RT,NUL;
RANY X;
RPTR(ERROR) EPTR;
MAKE_REMARK("Move");
DEFINE NULLINGCB = '1; ! Define some control bits for later use;
DEFINE WOBBLECB = '2;
DEFINE SPEEDFCB = '4;
! Duration: '20, '40, '60 for lower, upper & exact bounds;
DEFINE VELOCCB = '100;
DEFINE CODECB = '200;
DEFINE VIAPTCB = '400;
DEFINE DEPRPTCB = '1000;
DEFINE APPRPTCB = '2000;
DEFINE NODEPRCB = '4000; ! No departure point;
DEFINE DESTPTCB = '10000;
LAB1 ← GENLABEL; ! Start of Move;
EMIT(LAB1,SYMDEC); ! RETRY will re-do from here on;
LAB2 ← GENLABEL; ! End of Move;
LAB4 ← RETRY_LAB;
RETRY_LAB ← LAB1; ! Save old retry label & set up one for this move;
! Set up force frame (if any);
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF RECTYPE(X) = LOC(F_FRAME) THEN
BEGIN "f_frame"
EMITEXPR(F_FRAME:FRAME[X]); ! Get force frame;
EMIT(TFRCST_PSOP,PSINST); ! Set it up;
EMITOFFSET(F_FRAME:CF[X]); ! Control frame;
EMIT(F_FRAME:C_SYS[X],OCONST); ! Bits for co_ord sys;
! (hand or table);
DONE;
END "f_frame";
END;
! Set up all forces being applied in this MOVE;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF RECTYPE(X) = LOC(FORCE) THEN
BEGIN "force"
! First set up the control bits for COMPLY;
IF FORCE:DIRECT[X] = XHAT THEN BITS ← XFORCE
ELSE IF FORCE:DIRECT[X] = YHAT THEN BITS ← YFORCE
ELSE IF FORCE:DIRECT[X] = ZHAT THEN BITS ← ZFORCE
ELSE BEGIN "make force frame"
BITS ← XFORCE;
EMITEXPR(FORCE:DIRECT[X]); ! Get force vector;
EMIT(VMKFRC_PSOP,PSINST); ! Make force frame;
EMIT(TFRCST_PSOP,PSINST); ! Set it up;
EMITOFFSET(FORCE:CF[X]); ! Control frame;
EMIT(F_FRAME:C_SYS[FORCE:F_F[X]],OCONST); ! Bits for SETC;
END "make force frame";
IF ¬FORCE:TYPE[X] THEN BITS ← BITS + XMOMENT; ! It's a torque;
EMITEXPR(FORCE:VAL[X]); ! Get the force's magnitude;
EMIT(COMPLY_PSOP,PSINST);
EMITOFFSET(FORCE:CF[X]); ! Control frame;
EMIT(BITS,OCONST); ! Bits for COMPLY;
END "force";
END;
! See if we should zero the force wrist;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL ∧ RECTYPE(CELL:CAR[CLAUS]) ≠ LOC(SETBASE)
DO LLOP(CLAUS); ! Find the setbase clause if it's present;
IF CLAUS ≠ RNULL ∧ SETBASE:VAL[CELL:CAR[CLAUS]] THEN
BEGIN "setbase"
MAKE_REMARK("Setbase");
EMIT(SETBASE_PSOP,PSINST);
END "setbase";
! Set up stiffness/compliance for this MOVE;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL ∧ RECTYPE(CELL:CAR[CLAUS]) ≠ LOC(STIFF)
DO LLOP(CLAUS); ! Find the stiffness clause if it's present;
IF CLAUS ≠ RNULL THEN ! Got one;
BEGIN "stiff"
X←LLOP(CLAUS);
MAKE_REMARK("Set Stiff");
EMITEXPR(F_FRAME:FRAME[STIFF:F_F[X]]); ! Push compliance frame;
EMITEXPR(STIFF:G[X]); ! Push stiffness values - torque first;
EMITEXPR(STIFF:K[X]); ! then force;
EMIT(STIFF_PSOP,PSINST);
EMITOFFSET(F_FRAME:CF[STIFF:F_F[X]]); ! Control frame;
BITS ← F_FRAME:C_SYS[STIFF:F_F[X]];
EMIT(BITS,OCONST); ! Bits for co_ord sys (hand or table);
END "stiff";
! See if any force gathering to set up for this MOVE;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL ∧ RECTYPE(CELL:CAR[CLAUS]) ≠ LOC(GATHER)
DO LLOP(CLAUS); ! Find the gather clause if it's present;
IF CLAUS ≠ RNULL THEN ! Got it;
BEGIN "gather"
X←LLOP(CLAUS);
MAKE_REMARK("Set up Gathering");
EMIT(GATHR_PSOP,PSINST);
EMIT(GATHER:BITS[X],OCONST); ! Tell which forces to gather;
END "gather";
! Enable any condition monitors local to this move statement;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(VIA) THEN X ← VIA:CODE[X];
IF RECTYPE(X)=LOC(DEPARTURE) THEN X ← DEPARTURE:CODE[X];
IF RECTYPE(X)=LOC(APPROACH) THEN X ← APPROACH:CODE[X];
IF RECTYPE(X)=LOC(CMON) ∧ ¬DEFER_ON(CMON:FLAGS[X]) THEN
BEGIN "cmon"
MAKE_REMARK("Enable condition monitor");
EMIT(CMENBL_PSOP,PSINST);
EMIT(CMON:OFFSET[X],OCONST);
END "cmon"
END;
! Push on stack all deproaches & any expressions (via, dest, velocity, etc);
! Find the relevant clauses;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF (RT←RECTYPE(X)) = LOC(S_FAC) THEN SPD ← X
ELSE IF RT = LOC(APPROACH) ∧ APPROACH:THRU[X] ≠ NILDEPROACH THEN APR ← X
ELSE IF RT = LOC(DEPARTURE) THEN DEP ← X
ELSE IF RT = LOC(WOBBLE) THEN WOB ← X
ELSE IF RT = LOC(DURATION) THEN DUR ← X
ELSE IF RT = LOC(NNULL) ∧ ¬(NNULL:FLAG[X]) THEN NUL ← TRUE
ELSE IF RT = LOC(ERROR) THEN EPTR ← X
ELSE IF RT = LOC(VIA) THEN VIAL ← CONS(X,VIAL);
END;
! First take care of duration, speed_factor & wobble;
IF DUR ≠ RNULL ∧ RECTYPE(DURATION:TIME[DUR]) = LOC(EXPRN) THEN
EMITEXPR(DURATION:TIME[DUR]);
IF SPD ≠ RNULL ∧ RECTYPE(S_FAC:VAL[SPD]) = LOC(EXPRN) THEN
EMITEXPR(S_FAC:VAL[SPD]);
IF WOB ≠ RNULL ∧ RECTYPE(WOBBLE:VAL[WOB]) = LOC(EXPRN) THEN
EMITEXPR(WOBBLE:VAL[WOB]);
! Now generate code for the destination point, if it is an expression;
IF RECTYPE(MOVE$:DEST[PARSETREE]) = LOC(EXPRN) THEN
EMITEXPR(MOVE$:DEST[PARSETREE]);
! Deal with approach point, if any;
IF APR ≠ RNULL THEN
BEGIN
NSEGS ← 2;
EMITEXPR(APPROACH:ACTPLACE[APR]);
END
ELSE NSEGS ← 1;
! Now take care of the VIA points: velocity, duration & position;
CLAUS ← VIAL;
WHILE CLAUS ≠ RNULL DO
BEGIN "via exp"
NSEGS ← NSEGS + 1;
X ← LLOP(CLAUS);
IF VIA:VELOC[X] ≠ RNULL ∧
RECTYPE(VELOCITY:VELOC[VIA:VELOC[X]]) = LOC(EXPRN) THEN
EMITEXPR(VELOCITY:VELOC[VIA:VELOC[X]]);
IF VIA:TIME[X] ≠ RNULL ∧
RECTYPE(DURATION:TIME[VIA:TIME[X]]) = LOC(EXPRN) THEN
EMITEXPR(DURATION:TIME[VIA:TIME[X]]);
IF RECTYPE(VIA:PLACE[X]) = LOC(EXPRN) THEN EMITEXPR(VIA:PLACE[X]);
END "via exp";
! Deal with departure point, if any;
IF DEP ≠ RNULL THEN
BEGIN
IF DEPARTURE:THRU[DEP] ≠ NILDEPROACH THEN NSEGS ← NSEGS + 1;
IF DEPARTURE:ACTPLACE[DEP] ≠ RNULL THEN
EMITEXPR(DEPARTURE:ACTPLACE[DEP]);
END
ELSE NSEGS ← NSEGS + 1;
! Any subscripts for control frame?;
IF RECTYPE(MOVE$:CF[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for control frame");
EMITSUBS(CELL:CDR[EXPRN:ARGS[MOVE$:CF[PARSETREE]]])
END;
! Now we're ready to start making the trajectory;
EMIT(MOVE_PSOP,PSINST);
EMITOFFSET(MOVE$:CF[PARSETREE]); ! Tell who we're moving;
EMIT(NSEGS,CONST); ! Tell how many segments;
IF DEP ≠ RNULL THEN ! We have a departure point;
BEGIN
BITS ← DEPRPTCB;
IF DEPARTURE:THRU[DEP] = NILDEPROACH THEN BITS ← BITS lor NODEPRCB;
IF DEPARTURE:CODE[DEP] ≠ RNULL THEN BITS ← BITS lor CODECB;
EMIT(BITS,OCONST);
IF ¬(BITS land NODEPRCB) THEN EMIT(-1,OCONST); ! Always on stack;
IF BITS land CODECB THEN ! Event to signal;
EMITOFFSET(CMON:CONDITION[DEPARTURE:CODE[DEP]]);
END;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF RECTYPE(X) ≠ LOC(VIA) THEN CONTINUE; ! Only deal with VIA's here;
BITS ← VIAPTCB;
IF VIA:TIME[X] ≠ RNULL THEN
BITS ← BITS lor DURATION:TIME_RELN[VIA:TIME[X]];
IF VIA:CODE[X] ≠ RNULL THEN BITS ← BITS lor CODECB;
IF VIA:VELOC[X] ≠ RNULL THEN BITS ← BITS lor VELOCCB;
EMIT(BITS,OCONST);
IF (RT←RECTYPE(VIA:PLACE[X])) = LOC(VARIABLE)
THEN EMITOFFSET(VIA:PLACE[X])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(VIA:PLACE[X],FALSE); ! Constant, use label;
IF BITS land CODECB THEN ! Event to signal;
EMITOFFSET(CMON:CONDITION[VIA:CODE[X]]);
IF VIA:TIME[X] ≠ RNULL THEN
IF (RT←RECTYPE(DURATION:TIME[VIA:TIME[X]])) = LOC(VARIABLE)
THEN EMITOFFSET(DURATION:TIME[VIA:TIME[X]])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(DURATION:TIME[VIA:TIME[X]],FALSE); ! Constant;
IF VIA:VELOC[X] ≠ RNULL THEN
IF (RT←RECTYPE(VELOCITY:VELOC[VIA:VELOC[X]])) = LOC(VARIABLE)
THEN EMITOFFSET(VELOCITY:VELOC[VIA:VELOC[X]])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(VELOCITY:VELOC[VIA:VELOC[X]],FALSE); ! Constant;
END;
IF APR ≠ RNULL THEN
BEGIN ! We have an approach point;
BITS ← APPRPTCB;
IF APPROACH:CODE[APR] ≠ RNULL THEN BITS ← BITS lor CODECB;
EMIT(BITS,OCONST);
EMIT(-1,OCONST); ! Always on stack;
IF BITS land CODECB THEN ! Event to signal;
EMITOFFSET(CMON:CONDITION[APPROACH:CODE[APR]]);
END;
BITS ← DESTPTCB; ! Destination location;
! See if there's an ON ARRIVAL clause;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE (CLAUS ≠ RNULL) ∧ ¬( (RECTYPE(X←CELL:CAR[CLAUS]) = LOC(CMON))
∧ (RECTYPE(X←CMON:CONDITION[X]) = LOC(VARIABLE))
∧ EQU(".AE",VARIABLE:NAME[X][1 FOR 3]) )
DO CLAUS ← CELL:CDR[CLAUS];
IF (CLAUS ≠ RNULL) THEN BITS ← BITS lor CODECB;
EMIT(BITS,OCONST);
IF (RT←RECTYPE(MOVE$:DEST[PARSETREE])) = LOC(VARIABLE)
THEN EMITOFFSET(MOVE$:DEST[PARSETREE])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(MOVE$:DEST[PARSETREE],FALSE); ! Constant, use label;
IF BITS land CODECB THEN EMITOFFSET(X); ! Event to signal;
BITS ← IF NUL THEN 0 ELSE NULLINGCB; ! Control bits for entire move;
IF WOB ≠ RNULL THEN BITS ← BITS lor WOBBLECB;
IF DUR ≠ RNULL THEN BITS ← BITS lor DURATION:TIME_RELN[DUR];
IF SPD ≠ RNULL THEN BITS ← BITS lor SPEEDFCB;
EMIT(BITS,OCONST);
IF WOB ≠ RNULL THEN
IF (RT←RECTYPE(WOBBLE:VAL[WOB])) = LOC(VARIABLE)
THEN EMITOFFSET(WOBBLE:VAL[WOB])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(WOBBLE:VAL[WOB],FALSE); ! Constant, use label;
IF SPD ≠ RNULL THEN
IF (RT←RECTYPE(S_FAC:VAL[SPD])) = LOC(VARIABLE)
THEN EMITOFFSET(S_FAC:VAL[SPD])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(S_FAC:VAL[SPD],FALSE); ! Constant, use label;
IF DUR ≠ RNULL THEN
IF (RT←RECTYPE(DURATION:TIME[DUR])) = LOC(VARIABLE)
THEN EMITOFFSET(DURATION:TIME[DUR])
ELSE IF RT = LOC(EXPRN) THEN EMIT(-1,OCONST) ! On stack;
ELSE EMITEXPR(DURATION:TIME[DUR],FALSE); ! Constant, use label;
! That takes care of the trajectory info, now for error recovery;
BITS ← IF EPTR ≠ RNULL THEN SVAL:VAL[ERROR:BITS[EPTR]] ELSE 0;
EMIT(BITS,OCONST); ! error bit mask;
EMIT(LAB2,SYMREF); ! end of MOVE;
EMIT(LAB1,SYMREF); ! RETRY address;
IF EPTR ≠ RNULL THEN
BEGIN
MAKE_REMARK("Error handler");
TSCAN(ERROR:BODY[EPTR]); ! Generate code for error handler;
END;
RETRY_LAB ← LAB4; ! Restore old retry label;
! Disable any condition monitors local to this move statement;
EMIT(LAB2,SYMDEC); ! Come here if no error handler;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(VIA) THEN X ← VIA:CODE[X];
IF RECTYPE(X)=LOC(DEPARTURE) THEN X ← DEPARTURE:CODE[X];
IF RECTYPE(X)=LOC(APPROACH) THEN X ← APPROACH:CODE[X];
IF RECTYPE(X)=LOC(CMON) THEN
BEGIN "cmon"
MAKE_REMARK("Disable condition monitor");
EMIT(CMDSBL_PSOP,PSINST);
EMIT(CMON:OFFSET[X],OCONST);
END "cmon"
END;
! Update deproach variable if need be;
EMIT(UPDEPR_PSOP,PSINST);
END "move"
! TSCAN: OPERATE, CENTER, RETRY, STOP, SETBASE, WRIST;
ELSE IF STYP = LOC(OPERATE) THEN
BEGIN "operate"
RANY TIME_PTR, TORQUE_PTR, VELOCITY_PTR, SW_TIME_PTR, EPTR;
RANY X;
RCELL CLAUS; ! The list of clauses;
INTEGER DEV,BITS,MECH;
MAKE_REMARK("Operate");
LAB1 ← GENLABEL; ! Start of operate;
EMIT(LAB1,SYMDEC);
LAB2 ← GENLABEL; ! End of Operate;
LAB4 ← RETRY_LAB;
RETRY_LAB ← LAB1; ! Save old retry label & set up one for this move;
IF OPERATE:CF[PARSETREE] ≠ VISE AND
OPERATE:CF[PARSETREE] ≠ DRIVER
THEN COMERR("Can't OPERATE anything but the vise or driver yet");
! Find any clauses for this operate statement;
CLAUS ← OPERATE:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(ERROR) THEN EPTR ← X ELSE
IF RECTYPE(X)=LOC(DURATION) THEN TIME_PTR ← X ELSE
IF RECTYPE(X)=LOC(FORCE) THEN TORQUE_PTR ← X ELSE
IF RECTYPE(X)=LOC(VELOCITY) THEN VELOCITY_PTR ← X ELSE
IF RECTYPE(X)=LOC(SW_TIME) THEN SW_TIME_PTR ← X;
END;
IF OPERATE:CF[PARSETREE] = VISE THEN
BEGIN ! push vise values;
DEV ← VISESB;
MECH ← VISE_MECH;
IF RECTYPE(OPERATE:DEST[PARSETREE])=LOC(CHAR_REC) THEN
BEGIN ! open/close til touch;
BITS ← 1; ! Set no_nulling bit;
EMITEXPR(IF CHAR_REC:CHAR[OPERATE:DEST[PARSETREE]]="-" THEN FALSEV
ELSE NEW_SVAL(MAX_VISE_OPENING));
END
ELSE EMITEXPR(OPERATE:DEST[PARSETREE]);
IF bits = 0 THEN EMITEXPR(FALSEV) ! No stop wait time if width specified;
ELSE EMITEXPR(IF SW_TIME_PTR=RNULL THEN NEW_SVAL(0.25) ! ???***???;
ELSE SW_TIME:VAL[SW_TIME_PTR]);
EMITEXPR(IF TIME_PTR=RNULL THEN NEW_SVAL(8.00) ! *** should be enough;
ELSE DURATION:TIME[TIME_PTR]);
END ! push vise values;
ELSE
BEGIN ! push driver values;
DEV ← DRIVERSB;
MECH ← DRIVER_MECH;
BITS ← 0;
! velocity value will be ignored if torque value is specified;
EMITEXPR(IF VELOCITY_PTR=RNULL THEN NEW_SVAL(60.0)
ELSE VELOCITY:VELOC[VELOCITY_PTR]);
EMITEXPR(IF TORQUE_PTR=RNULL THEN FALSEV
ELSE FORCE:VAL[TORQUE_PTR]);
EMITEXPR(IF TIME_PTR=RNULL THEN NEW_SVAL(5.00) ! *** enough??? ***;
ELSE DURATION:TIME[TIME_PTR]);
END;
! Enable any condition monitors local to this operate statement;
CLAUS ← OPERATE:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(CMON) ∧ ¬DEFER_ON(CMON:FLAGS[X]) THEN
BEGIN "cmon"
MAKE_REMARK("Enable condition monitor");
EMIT(CMENBL_PSOP,PSINST);
EMIT(CMON:OFFSET[X],OCONST);
END "cmon"
END;
EMIT(OPERATE_PSOP,PSINST);
EMIT(DEV,OCONST); ! which device - servo bits;
EMIT(BITS,OCONST); ! command bits - for vise;
EMIT(MECH,OCONST); ! mechanism bits;
BITS ← IF EPTR ≠ RNULL THEN SVAL:VAL[ERROR:BITS[EPTR]] ELSE 0;
EMIT(BITS,OCONST); ! error bit mask;
EMIT(LAB2,SYMREF); ! end of OPERATE;
EMIT(LAB1,SYMREF); ! error address;
IF EPTR ≠ RNULL THEN
BEGIN
MAKE_REMARK("Error handler");
TSCAN(ERROR:BODY[EPTR]); ! Generate code for error handler;
END;
RETRY_LAB ← LAB4; ! Restore old retry label;
! Disable any condition monitors local to this operate statement;
EMIT(LAB2,SYMDEC); ! Come here if no error handler;
CLAUS ← OPERATE:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(CMON) THEN
BEGIN "cmon"
MAKE_REMARK("Disable condition monitor");
EMIT(CMDSBL_PSOP,PSINST);
EMIT(CMON:OFFSET[X],OCONST);
END "cmon"
END;
END "operate"
ELSE IF STYP = LOC(CENTER) THEN
BEGIN "center"
RPTR(ERROR) EPTR;
RANY X,CLAUS;
INTEGER BITS,MECH;
MAKE_REMARK("Center");
LAB1 ← GENLABEL; ! Start of Center;
EMIT(LAB1,SYMDEC); ! RETRY will re-do from here on;
LAB2 ← GENLABEL; ! End of Center;
LAB4 ← RETRY_LAB;
RETRY_LAB ← LAB1; ! Save old retry label & set up one for this move;
! Find any clauses for this center statement;
CLAUS ← CENTER:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(ERROR) THEN EPTR ← X;
END;
IF CENTER:CF[PARSETREE] = YARM THEN MECH ← YARM_MECH + YHAND_MECH
ELSE MECH ← BARM_MECH + BHAND_MECH;
EMIT(CENTER_PSOP,PSINST);
EMIT(MECH,OCONST); ! mechanism bits;
BITS ← IF EPTR ≠ RNULL THEN SVAL:VAL[ERROR:BITS[EPTR]] ELSE 0;
EMIT(BITS,OCONST); ! error bit mask;
EMIT(LAB2,SYMREF); ! end of CENTER;
EMIT(LAB1,SYMREF); ! error address;
IF EPTR ≠ RNULL THEN
BEGIN
MAKE_REMARK("Error handler");
TSCAN(ERROR:BODY[EPTR]); ! Generate code for error handler;
END;
RETRY_LAB ← LAB4; ! Restore old retry label;
EMIT(LAB2,SYMDEC); ! Come here if no error handler;
END "center"
ELSE IF STYP = LOC(RETRY) THEN
BEGIN "retry"
MAKE_REMARK("Retry");
IF RETRY_LAB ≠ 0 THEN
BEGIN
EMIT(JUMP_PSOP,PSINST);
EMIT(RETRY_LAB,SYMREF); ! retry address;
END
ELSE COMERR("RETRY not inside error handler. Will ignore it.");
END "retry"
ELSE IF STYP = LOC(STOP) THEN
BEGIN "stop"
MAKE_REMARK("Stop");
EMIT(STOP_PSOP,PSINST);
EMITOFFSET(STOP:CF[PARSETREE]);
END "stop"
ELSE IF STYP = LOC(SETBASE) THEN
BEGIN "setbase"
MAKE_REMARK("Setbase");
EMIT(SETBASE_PSOP,PSINST);
END "setbase"
ELSE IF STYP = LOC(WRIST) THEN
BEGIN "wrist"
MAKE_REMARK("wrist");
EMIT(WRIST_PSOP,PSINST);
EMITOFFSET(WRIST:K[PARSETREE]);
EMITOFFSET(WRIST:G[PARSETREE]);
END "wrist"
! TSCAN: COMMENT, AFFIX, UNFIX;
ELSE IF STYP = LOC(COMMNT) THEN
BEGIN "commnt"
END "commnt"
ELSE IF STYP = LOC(AFFIX) THEN
BEGIN "affix"
INTEGER BITS;
MAKE_REMARK("Affixment");
IF AFFIX:ATEXP[PARSETREE] ≠ RNULL THEN
BEGIN ! Explicitly given AT expression;
EMITEXPR(AFFIX:ATEXP[PARSETREE]);
BITS ← 0;
END
ELSE BITS ← '100000; ! Indicate the trans should be computed by runtime;
IF RECTYPE(AFFIX:BYVAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for byvar");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:BYVAR[PARSETREE]]])
END;
IF RECTYPE(AFFIX:FRAME2[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for frame2");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:FRAME2[PARSETREE]]])
END;
IF RECTYPE(AFFIX:FRAME1[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for frame1");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:FRAME1[PARSETREE]]])
END;
IF ¬AFFIX:RIGID[PARSETREE] THEN BITS ← BITS + '400; ! Non-rigid;
IF RECTYPE(AFFIX:BYVAR[PARSETREE]) = LOC(EXPRN) ∨
VARIABLE:NAME[AFFIX:BYVAR[PARSETREE]] ≠ NULL THEN LAB1 ← TRUE
ELSE LAB1 ← FALSE; ! if ALC generated;
IF LAB1 THEN BITS ← BITS + '2000; ! Explicitly named trans;
EMIT(AFFIX_PSOP,PSINST);
EMITOFFSET(AFFIX:FRAME1[PARSETREE]);
EMITOFFSET(AFFIX:FRAME2[PARSETREE]);
EMIT(BITS,OCONST); ! Tell what type of affixment to make;
IF LAB1 THEN EMITOFFSET(AFFIX:BYVAR[PARSETREE]);
MAKE_REMARK("End of affixment");
END "affix"
ELSE IF STYP = LOC(UNFIX) THEN
BEGIN "unfix"
MAKE_REMARK("Unfixment");
IF RECTYPE(UNFIX:FRAME2[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for frame2");
EMITSUBS(CELL:CDR[EXPRN:ARGS[UNFIX:FRAME2[PARSETREE]]])
END;
IF RECTYPE(UNFIX:FRAME1[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for frame1");
EMITSUBS(CELL:CDR[EXPRN:ARGS[UNFIX:FRAME1[PARSETREE]]])
END;
EMIT(UNFIX_PSOP,PSINST);
EMITOFFSET(UNFIX:FRAME1[PARSETREE]);
EMITOFFSET(UNFIX:FRAME2[PARSETREE]);
END "unfix"
! TSCAN: EVDO;
ELSE IF STYP = LOC(EVDO) THEN
BEGIN "evdo"
MAKE_REMARK("Event operation");
IF RECTYPE(EVDO:VAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK("Subscripts for event var");
EMITSUBS(CELL:CDR[EXPRN:ARGS[EVDO:VAR[PARSETREE]]]);
END;
IF EVDO:OP[PARSETREE] = 0
THEN EMIT(SIGNAL_PSOP,PSINST)
ELSE EMIT(WAITE_PSOP,PSINST);
EMITOFFSET(EVDO:VAR[PARSETREE]);
END "evdo"
! UNRECOGNIZED;
ELSE IF PARSETREE ≠ RNULL THEN
COMERR("Can't generate code for this",PARSETREE);
ENDLABEL: ! This is here to avoid parse stack overflow;
END "tscan";
END $$prgid;